home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH6 / SRC / LEASTSQ2.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1996-03-29  |  4.9 KB  |  165 lines
  1. VERSION 4.00
  2. Begin VB.Form LeastSquareForm 
  3.    Caption         =   "Quadratic Least Squares"
  4.    ClientHeight    =   5310
  5.    ClientLeft      =   2085
  6.    ClientTop       =   900
  7.    ClientWidth     =   4830
  8.    Height          =   6000
  9.    Left            =   2025
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   354
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   322
  14.    Top             =   270
  15.    Width           =   4950
  16.    Begin VB.CommandButton CmdGo 
  17.       Caption         =   "Go"
  18.       Default         =   -1  'True
  19.       Enabled         =   0   'False
  20.       Height          =   375
  21.       Left            =   2040
  22.       TabIndex        =   1
  23.       Top             =   4920
  24.       Width           =   615
  25.    End
  26.    Begin VB.PictureBox Canvas 
  27.       AutoRedraw      =   -1  'True
  28.       Height          =   4815
  29.       Left            =   0
  30.       ScaleHeight     =   317
  31.       ScaleMode       =   3  'Pixel
  32.       ScaleWidth      =   317
  33.       TabIndex        =   0
  34.       Top             =   0
  35.       Width           =   4815
  36.    End
  37.    Begin VB.Menu mnuFile 
  38.       Caption         =   "&File"
  39.       Begin VB.Menu mnuFileExit 
  40.          Caption         =   "E&xit"
  41.       End
  42.    End
  43. Attribute VB_Name = "LeastSquareForm"
  44. Attribute VB_Creatable = False
  45. Attribute VB_Exposed = False
  46. Option Explicit
  47. Dim NumPts As Integer
  48. Dim PtX() As Single
  49. Dim PtY() As Single
  50. ' ************************************************
  51. ' Compute the a, b, and c values for the least
  52. ' squares quadratic.
  53. ' ************************************************
  54. Sub GetLeastSquaresValues(num As Integer, x() As Single, Y() As Single, avalue As Single, bvalue As Single, cvalue As Single)
  55. Dim A As Single
  56. Dim B As Single
  57. Dim C As Single
  58. Dim D As Single
  59. Dim E As Single
  60. Dim F As Single
  61. Dim G As Single
  62. Dim x2 As Single
  63. Dim x3 As Single
  64. Dim x4 As Single
  65. Dim C2BE As Single
  66. Dim E2CN As Single
  67. Dim BDAF As Single
  68. Dim CFBG As Single
  69. Dim ACB2 As Single
  70. Dim denom As Single
  71. Dim i As Integer
  72.     ' Compute the sums.
  73.     For i = 1 To NumPts
  74.         x2 = PtX(i) * PtX(i)
  75.         x3 = x2 * PtX(i)
  76.         x4 = x2 * x2
  77.         A = A + x4
  78.         B = B + x3
  79.         C = C + x2
  80.         D = D + PtY(i) * x2
  81.         E = E + PtX(i)
  82.         F = F + PtY(i) * PtX(i)
  83.         G = G + PtY(i)
  84.     Next i
  85.     ' Compute the quadratic parameters.
  86.     C2BE = C * C - B * E
  87.     E2CN = E * E - C * NumPts
  88.     BDAF = B * D - A * F
  89.     CFBG = C * F - B * G
  90.     ACB2 = A * C - B * B
  91.     denom = (B * C - A * E) * C2BE - _
  92.             (C * E - B * NumPts) * (B * B - A * C)
  93.     avalue = _
  94.     ((C * D - B * F) * E2CN - (E * F - C * G) * C2BE) / _
  95.     (ACB2 * E2CN + C2BE * C2BE)
  96.     bvalue = _
  97.     (CFBG * (B * C - A * E) - BDAF * (C * E - B * NumPts)) / _
  98.     denom
  99.     cvalue = _
  100.     (BDAF * (C * C - B * E) + CFBG * ACB2) / _
  101.     denom
  102. End Sub
  103. ' ************************************************
  104. ' Add this point to the list of points.
  105. ' ************************************************
  106. Private Sub Canvas_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
  107. Const GAP = 2
  108.     ' If this is the first point, erase the screen.
  109.     If NumPts < 1 Then Canvas.Cls
  110.     ' Record the new point.
  111.     NumPts = NumPts + 1
  112.     ReDim Preserve PtX(1 To NumPts)
  113.     ReDim Preserve PtY(1 To NumPts)
  114.     PtX(NumPts) = x
  115.     PtY(NumPts) = Y
  116.     ' Display the point.
  117.     Canvas.Line (x - GAP, Y - GAP)-(x + GAP, Y + GAP), , BF
  118.     ' If NumPts >= 2, enable the Go button.
  119.     If NumPts >= 2 Then CmdGo.Enabled = True
  120. End Sub
  121. ' ************************************************
  122. ' Draw the least squares fit curve.
  123. ' ************************************************
  124. Private Sub CmdGo_Click()
  125.     CmdGo.Enabled = False
  126.     DrawCurve
  127.     ' Prepare to get a new set of points.
  128.     NumPts = 0
  129. End Sub
  130. ' ************************************************
  131. ' Draw the least squares line.
  132. ' ************************************************
  133. Sub DrawCurve()
  134. Dim A As Single
  135. Dim B As Single
  136. Dim C As Single
  137. Dim x1 As Single
  138. Dim x2 As Single
  139. Dim i As Integer
  140. Dim x As Single
  141. Dim dx As Single
  142.     ' Get the parameters for the quadratic.
  143.     GetLeastSquaresValues NumPts, PtX, PtY, A, B, C
  144.     ' Find the minimum and maximum X values.
  145.     x1 = PtX(1) ' This will be the minimum X value.
  146.     x2 = x1     ' This will be the maximum X value.
  147.     For i = 2 To NumPts
  148.         If x1 > PtX(i) Then x1 = PtX(i)
  149.         If x2 < PtX(i) Then x2 = PtX(i)
  150.     Next i
  151.     ' Draw the curve.
  152.     Canvas.CurrentX = x1
  153.     Canvas.CurrentY = A * x1 * x1 + B * x1 + C
  154.     dx = (x2 - x1) / 100    ' Use 100 increments.
  155.     x = x1 + dx
  156.     Do While x < x2
  157.         Canvas.Line -(x, A * x * x + B * x + C)
  158.         x = x + dx
  159.     Loop
  160.     Canvas.Line -(x2, A * x2 * x2 + B * x2 + C)
  161. End Sub
  162. Private Sub mnuFileExit_Click()
  163.     Unload Me
  164. End Sub
  165.